perm filename CB.F4[DRW,LCS]5 blob
sn#449476 filedate 1979-06-10 generic text, type T, neo UTF8
00100 SUBROUTINE CMBN
00200 COMMON /RC/MCLEF(400),IST(4000)
00300 COMMON /FL/NX,N,L,M,NM,J,NT
00400 DIMENSION IP(10),NMS(10),NF(2500),JP(10),NMX(10)
00500 EQUIVALENCE (IP,IST(3001)),(NMS,IST(3020)),(NF,IST(201))
00600 1,(JP,IST(1500)),(NMX,IST(1510))
00700 C ***** ****** **** ****** ↑ 20 FOR OVERRUN IN IP(11) AT 119
00800 C USE FILE NAMES CLFX, DRAW1 AND DRAW2. 400 WD LIMIT PER FILE.
00900 IF(N.EQ.'S')GO TO 103
01000 102 TYPE 1
01100 1 FORMAT(' TYPE OUTPUT FILE NAME ',$)
01200 10 FORMAT(A5)
01300 DO 122 K=1,10
01400 IP(K)=0
01500 122 NMS(K)=' '
01600 ACCEPT 10,NM
01700 IF(NM.NE.' ')GO TO 40
01800 NM=LASTNM
01900 TYPE 107,LASTNM
02000 40 LASTNM=NM
02100 IF(LOOKF(NM).EQ.0)GO TO 100
02200 IF(N.NE.'C')GO TO 103
02300 C FOR ADDING TO COMBINED FILE.
02400 TYPE 101,NM
02500 ACCEPT 10,NX
02600 IF(NX.EQ.'N')GO TO 102
02700 100 IF(N.EQ.'C')GO TO 104
02800 TYPE 52
02900 GO TO 102
03000 104 L=0
03100 NX=1
03200 I=0
03300 30 L=L+1
03400 TYPE 41
03500 41 FORMAT(' TYPE FILE NAME ',$)
03600 ACCEPT 10,NW
03700 IF(NW.EQ.' ')GO TO 8
03800 IF(LOOKF(NW))GO TO 51
03900 TYPE 52
04000 GO TO 30
04100 52 FORMAT(' FILE NOT FOUND'/)
04200 51 I=I+1
04300 IP(L)=NX
04400 NMS(I)=NW
04500 CALL RDSAV(JP,NMX,K,NW,MCLEF(NX),-2)
04600 NX=NX+K
04700 IF(L.LT.10)GO TO 30
04800 101 FORMAT(' WRITE OVER ',A5,'.DMD? Y OR N? ',$)
04900 8 NX=NX-1
05000 14 CALL RDSAV(IP,NMS,NX,NM,MCLEF,0)
05100 L=NX
05200 RETURN
05300
05400 1103 TYPE 1104,ID
05500 1104 FORMAT(' FILE FULL -- SAVED AS ',A5)
05600 L=1
05700 NM=ID
05800 NX=MCLEF(1)
05900 GO TO 8
06000
06100 103 CALL RDSAV(IP,NMS,NX,NM,NF,-1)
06200 107 FORMAT(1X,A5)
06300 TYPE 109
06400 109 FORMAT(' TYPE ID NAME (<CR>=BACKUP) -- ',$)
06500 ACCEPT 10,ID
06600 IF(ID.EQ.' ')GO TO 102
06700 JD=0
06800 L=0
06900 CC NX=NX-1
07000 DO 110 K=1,10
07100 IF(NMS(K).EQ.ID)JD=K
07200 IF(NMS(K).EQ.' ')GO TO 112
07300 L=K
07400 110 IF(JD.EQ.0.AND.K.EQ.10)GO TO 1103
07500 112 IF(N.EQ.'Z')GO TO 127
07600 C FOR DELETIONS
07700 L=L+1
07800 IF(JD.NE.0)GO TO 111
07900 C ADDS ON TO END
08000 N=0
08100 IP(L)=NX+1
08200 DO 113 K=NX+1,MCLEF(1)+NX
08300 N=N+1
08400 113 NF(K)=MCLEF(N)
08500 NX=NX+N
08600 NMS(L)=ID
08700 L=L+1
08800 114 DO 115 K=1,NX
08900 115 MCLEF(K)=NF(K)
09000 C MOVES IT ALL TO MCLEF
09100 GO TO 14
09200
09300 127 MCLEF(1)=0
09400 111 N=IP(JD)
09500 NR=MCLEF(1)
09600 M=NF(IP(JD))
09700 NW=NR-M
09800 NX=NX+NW
09900 IF(NW)201,120,203
10000 201 JA=N+NR
10100 JB=NX
10200 JC=1
10300 GO TO 204
10400 203 JA=NX
10500 JB=N+NW
10600 JC=-1
10700 204 DO 121 K=JA,JB,JC
10800 121 NF(K)=NF(K-NW)
10900 IF(NR.EQ.0)GO TO 126
11000 120 DO 117 K=1,NR
11100 NF(N)=MCLEF(K)
11200 117 N=N+1
11300 CC L=L-1
11400 IF(NW.EQ.0)GO TO 114
11500 DO 119 K=JD+1,L
11600 119 IP(K)=IP(K)+NW
11700 C FIXES UP FIRST LINE.
11800 CC123 L=L-1
11900 CC NX=NX-1
12000 GO TO 114
12100 126 IP(L+1)=0
12200 CC L=L-1
12300 DO 124 K=JD,L-1
12400 IP(K)=IP(K+1)+NW
12500 124 NMS(K)=NMS(K+1)
12600 NMS(L)=' '
12700 GO TO 114
12800 END
12900
13000 SUBROUTINE RDSAV(KT,NMS,K,NAME,IO,L)
13100 C POINTER LIST, NAME LIST, WDCNT, FILE NAME, DATA, RD OR WRT.
13200 COMMON /RC/MCLEF(400),IST(4000)/FL/IC,NH,NQ,A,B,C,D
13300 DIMENSION KT(1),NMS(1),IO(1),JALL(21)
13400 IF(L)GO TO 5
13500 C L=-1 FOR READER, -2=NO TYPE OF NAME LIST.
13600 DO 1 N=1,10
13700 JALL(N)=KT(N)
13800 1 JALL(N+11)=NMS(N)
13900 JALL(11)=K
13950 TYPE 6,K
14000 CALL PUTFIL(NAME)
14100 CALL FASTOU(JALL,21)
14200 CALL FASTOU(IO,K+1)
14300 CALL FINFIL
14400 RETURN
14500
14600 5 CALL GETFIL(NAME)
14700 CALL FASTIN(JALL,21)
14800 K=JALL(11)
14820 TYPE 6,K
14840 6 FORMAT(' TOTAL WDS=',I3,'/350')
14900 CALL FASTIN(IO,K)
15000 DO 2 N=1,10
15100 KT(N)=JALL(N)
15200 2 NMS(N)=JALL(N+11)
15300 IF(L.EQ.-2)RETURN
15400 TYPE 3
15500 TYPE 4,(NMS(N),N=1,10)
15600 3 FORMAT(
15700 1' 0 1 2 3 4 5 6 7
15800 1 8 9')
15900 4 FORMAT(' IDENT. NAMES:'/,10(2XA5))
16000 END
16100
16200 SUBROUTINE CNVT
16300 COMMON/RC/A(4400)
16400 DIMENSION J(10),NM(10),M(600),JALL(21)
16500 EQUIVALENCE(J,JALL,A),(NX,JALL(11)),(NM,JALL(12)),(M,A(2000))
16600 C POINTER LIST, TOTAL WD CNT, NAME LIST.
16700 TYPE 1
16800 1 FORMAT(' TYPE OLD NAME -- '$)
16900 ACCEPT 2,N
17000 2 FORMAT(A5)
17100 TYPE 3
17200 3 FORMAT(' NEW NAME -- '$)
17300 ACCEPT 2,NN
17400 CALL IFILE(1,N)
17500 NX=1
17600 READ(1,4)K,J
17700 4 FORMAT(12I)
17800 6 READ(1,4,END=5)K,K,(M(L),L=NX,NX+K-1)
17900 REREAD 7,L,NM
18000 IF(NM(1))GO TO 5
18100 NX=NX+K
18200 GO TO 6
18300 7 FORMAT(I,10A5)
18400
18500 5 NX=NX-1
18600 CALL RDSAV(J,NM,NX,NN,M,0)
18700 C POINTERS, NAMES, WDCNT, FILE NAME, ARRAY, 0=WRITE
18800 CALL EXIT
18900 END